home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gnat1792.zip / gnat179b / t-adainc / a-strfix.adb < prev    next >
Text File  |  1994-05-19  |  15KB  |  498 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                    A D A . S T R I N G S . F I X E D                     --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.3 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. --  Note: This code is derived from the ADAR.CSH public domain Ada 83
  26. --  versions of the Appendix C string handling packages. One change is
  27. --  to avoid the use of Is_In, so that we are not dependent on inlining.
  28. --  Note that the search function implementations are to be found in the
  29. --  auxiliary package Ada.Strings.Search. Also the Move procedure is
  30. --  directly incorporated (ADAR used a subunit for this procedure)
  31.  
  32.  
  33. package body Ada.Strings.Fixed is
  34.  
  35.    -----------------------
  36.    -- Local Subprograms --
  37.    -----------------------
  38.  
  39.    function Max (Item_1, Item_2 : Integer) return Integer;
  40.    --  Return maximum of two integers (this should be replaced by use of
  41.    --  the 'Max attribute when GNAT implements this attribute ???)
  42.  
  43.    function Max (Item_1, Item_2 : Integer) return Integer is
  44.    begin
  45.       if Item_1 >= Item_2 then
  46.          return Item_1;
  47.       else
  48.          return Item_2;
  49.       end if;
  50.    end Max;
  51.  
  52.    ---------
  53.    -- "*" --
  54.    ---------
  55.  
  56.    function "*" (Left  : in Natural;
  57.                  Right : in Character) return String
  58.    is
  59.       Result : String (1 .. Left);
  60.  
  61.    begin
  62.       for I in Result'range loop
  63.          Result (I) := Right;
  64.       end loop;
  65.  
  66.       return Result;
  67.    end "*";
  68.  
  69.    function "*" (Left  : in Natural;
  70.                  Right : in String) return String
  71.    is
  72.       Result : String (1 .. Left * Right'Length);
  73.       Ptr    : Integer := 1;
  74.  
  75.    begin
  76.       for I in 1 .. Left loop
  77.          Result (Ptr .. Ptr + Right'Length - 1) := Right;
  78.          Ptr := Ptr + Right'Length;
  79.       end loop;
  80.  
  81.       return Result;
  82.    end "*";
  83.  
  84.    ------------
  85.    -- Delete --
  86.    ------------
  87.  
  88.    function Delete (Source  : in String;
  89.                     From    : in Positive;
  90.                     Through : in Natural)
  91.      return String
  92.    is
  93.       Result : String (1 .. Source'Length - Max (Through - From + 1, 0));
  94.    begin
  95.       if From not in Source'range or else Through > Source'Last then
  96.          raise Index_Error;
  97.       end if;
  98.  
  99.       Result := Source (Source'First .. From - 1) &
  100.                 Source (Through + 1 .. Source'Last);
  101.       return Result;
  102.    end Delete;
  103.  
  104.    procedure Delete (Source  : in out String;
  105.                      From    : in Positive;
  106.                      Through : in Natural;
  107.                      Justify : in Alignment := Left;
  108.                      Pad     : in Character := Fixed.Pad) is
  109.    begin
  110.       Move (Source  => Delete (Source, From, Through),
  111.             Target  => Source,
  112.             Justify => Justify,
  113.             Pad     => Pad);
  114.    end Delete;
  115.  
  116.    ----------
  117.    -- Head --
  118.    ----------
  119.  
  120.    function Head (Source : in String;
  121.                   Count  : in Natural;
  122.                   Pad    : in Character := Fixed.Pad)
  123.      return String
  124.    is
  125.       Result : String (1 .. Count);
  126.  
  127.    begin
  128.       if Count < Source'Length then
  129.          Result := Source (Source'First .. Source'First + Count - 1);
  130.  
  131.       else
  132.          Result (1 .. Source'Length) := Source;
  133.  
  134.          for I in Source'Length + 1 .. Count loop
  135.             Result (I) := Pad;
  136.          end loop;
  137.       end if;
  138.  
  139.       return Result;
  140.    end Head;
  141.  
  142.    ------------
  143.    -- Insert --
  144.    ------------
  145.  
  146.    function Insert (Source   : in String;
  147.                     Before   : in Positive;
  148.                     New_Item : in String)
  149.      return String
  150.    is
  151.       Result : String (1 .. Source'Length + New_Item'Length);
  152.  
  153.    begin
  154.       if Before < Source'First or else Before > Source'Last + 1 then
  155.          raise Index_Error;
  156.       end if;
  157.  
  158.       Result := Source (Source'First .. Before - 1) & New_Item &
  159.                 Source (Before .. Source'Last);
  160.       return Result;
  161.    end Insert;
  162.  
  163.    procedure Insert (Source   : in out String;
  164.                      Before   : in Positive;
  165.                      New_Item : in String;
  166.                      Drop     : in Truncation := Error) is
  167.    begin
  168.       Move (Source => Insert (Source, Before, New_Item),
  169.             Target => Source,
  170.             Drop   => Drop);
  171.    end Insert;
  172.  
  173.    ----------
  174.    -- Move --
  175.    ----------
  176.  
  177.    procedure Move (Source  : in  String;
  178.                    Target  : out String;
  179.                    Drop    : in  Truncation := Error;
  180.                    Justify : in  Alignment  := Left;
  181.                    Pad     : in  Character  := Ada.Strings.Fixed.Pad)
  182.    is
  183.       Sfirst  : constant Integer := Source'First;
  184.       Slast   : constant Integer := Source'Last;
  185.       Slength : constant Integer := Source'Length;
  186.  
  187.       Tfirst  : constant Integer := Target'First;
  188.       Tlast   : constant Integer := Target'Last;
  189.       Tlength : constant Integer := Target'Length;
  190.  
  191.       function Is_Padding (Item : String) return Boolean is
  192.       begin
  193.          for I in Item'range loop
  194.             if Item (I) /= Pad then
  195.                return False;
  196.             end if;
  197.          end loop;
  198.  
  199.          return True;
  200.       end Is_Padding;
  201.  
  202.    --  Start of processing for Move
  203.  
  204.    begin
  205.       if Slength = Tlength then
  206.          Target := Source;
  207.  
  208.       elsif Slength > Tlength then
  209.  
  210.          case Drop is
  211.             when Left =>
  212.                Target := Source (Slast - Tlength + 1 .. Slast);
  213.  
  214.             when Right =>
  215.                Target := Source (Sfirst .. Sfirst + Tlength - 1);
  216.  
  217.             when Error =>
  218.                case Justify is
  219.                   when Left =>
  220.                      if Is_Padding (Source (Sfirst + Tlength .. Slast)) then
  221.                         Target :=
  222.                           Source (Sfirst .. Sfirst + Target'Length - 1);
  223.                      else
  224.                         raise Length_Error;
  225.                      end if;
  226.  
  227.                   when Right =>
  228.                      if Is_Padding (Source (Sfirst .. Slast - Tlength)) then
  229.                         Target := Source (Slast - Tlength + 1 .. Slast);
  230.                      else
  231.                         raise Length_Error;
  232.                      end if;
  233.  
  234.                   when Center =>
  235.                      raise Length_Error;
  236.                end case;
  237.  
  238.          end case;
  239.  
  240.       else -- Source'Length < Target'Length
  241.  
  242.          case Justify is
  243.             when Left =>
  244.                Target (Tfirst .. Tfirst + Slength - 1) := Source;
  245.  
  246.                for I in Tfirst + Slength .. Tlast loop
  247.                   Target (I) := Pad;
  248.                end loop;
  249.  
  250.             when Right =>
  251.                for I in Tfirst .. Tlast - Slength loop
  252.                   Target (I) := Pad;
  253.                end